Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue51/ComCorn/VarCache.pas

Pascal/Delphi Source File | 1999-10-12 | 8.4 KB | 324 lines

unit VarCache;

interface

uses WIndows, Classes, ActiveX;

type
  TVariantCache = class;

  // Class representing one variant and associated dispatch methods
  TVariantEntry = class(TObject)
  private
    FDispValue: Pointer;
    FRefCount: Integer;
    FDispIds: TStringList;
    FNext: TVariantEntry;
    FPrev: TVariantEntry;
    FOwner: TVariantCache;
  public
    constructor Create(const V: OleVariant; PrevEntry: TVariantEntry;
      AOwner: TVariantCache);
    destructor Destroy; override;
    function GetIdsOfNames(Names: PChar; DispIDs: PDispIDList): Boolean;
  end;

  // Class representing a circular doubly-linked list of TVariantEntries
  TVariantCache = class(TObject)
  private
    FVariantEntries: TVariantEntry;
  public
    function Add(const V: OleVariant; Names: PChar; DispIDs: PDispIDList;
      Length: Integer): TVariantEntry;
    procedure Remove(const V: OleVariant);
    function Find(const V: OleVariant): TVariantEntry;
  end;

implementation

uses ComObj, SysUtils;

type
  TDynDispIDList = array of TDispID;

const
  MemSize = 6;

var
  OldVarClear, NewVarClear: PByte;
  VarClearCode: array[1..MemSize] of Byte;
  VariantCache: TVariantCache;

{ TVariantEntry }

constructor TVariantEntry.Create(const V: OleVariant;
  PrevEntry: TVariantEntry; AOwner: TVariantCache);
begin
  FOwner := AOwner;
  FDispValue := TVarData(V).VDispatch;
  FRefCount := 1;
  FDispIds := TStringList.Create;
  FDispIds.Duplicates := dupError;
  FDispIDs.Sorted := True;
  if PrevEntry <> nil then
  begin
    FPrev := PrevEntry;
    if PrevEntry.FNext = nil then FNext := PrevEntry
    else FNext := PrevEntry.FNext;
    FNext.FPrev := Self;
    PrevEntry.FNext := Self;
  end;
end;

destructor TVariantEntry.Destroy;
var
  I: Integer;
  List: TDynDispIdList;
begin
  List := nil;
  for I := FDispIds.Count - 1 downto 0 do
  begin
    TObject(List) := FDispIds.Objects[I];
    List := nil;
  end;
  FDispIDs.Free;
  inherited Destroy;
  if FNext <> nil then
  begin
    if FNext.FNext = Self then
    begin
      FNext.FNext := nil;
      FNext.FPrev := nil;
    end
    else begin
      FNext.FPrev := FPrev;
      FPrev.FNext := FNext;
    end;
    FOwner.FVariantEntries := FNext;
  end
  else
    FOwner.FVariantEntries := nil;
end;

function TVariantEntry.GetIdsOfNames(Names: PChar;
  DispIDs: PDispIDList): Boolean;
var
  Index: Integer;
  ArrayObj: TObject;
begin
  Result := FDispIds.Find(Names, Index);
  if Result then
  begin
    ArrayObj := FDispIds.Objects[Index];
    Move(TDynDispIdList(ArrayObj)[0], DispIDs^,
      Length(TDynDispIdList(ArrayObj)) * SizeOf(TDispID));
  end;
end;

{ TVariantCache }

function TVariantCache.Add(const V: OleVariant; Names: PChar;
  DispIDs: PDispIDList; Length: Integer): TVariantEntry;
var
  List: TDynDispIdList;
  Index: Integer;
begin
  Result := Find(V);
  SetLength(List, Length);
  Move(DispIDs^, List[0], Length * SizeOf(TDispID));
  if Result <> nil then
  begin
    Inc(Result.FRefCount);
    if not Result.FDispIds.Find(Names, Index) then
      Result.FDispIds.AddObject(Names, TObject(List));
  end
  else begin
    Result := TVariantEntry.Create(V, FVariantEntries, Self);
    Result.FDispIds.AddObject(Names, TObject(List));
  end;
  Pointer(List) := nil;  // prevent automatic cleanup of dynamic array
  FVariantEntries := Result;
end;

function TVariantCache.Find(const V: OleVariant): TVariantEntry;
var
  VarEntry: TVariantEntry;
begin
  Result := nil;
  if FVariantEntries <> nil then
  begin
    VarEntry := FVariantEntries;
    repeat
      if VarEntry.FDispValue = TVarData(V).VDispatch then
      begin
        Result := VarEntry;
        FVariantEntries := Result;
        Exit;
      end;
      VarEntry := VarEntry.FNext;
    until (VarEntry = FVariantEntries) or (VarEntry = nil);
  end;
end;

procedure TVariantCache.Remove(const V: OleVariant);
var
  VarEntry: TVariantEntry;
begin
  if TVarData(V).VType = varDispatch then
  begin
    VarEntry := Find(V);
    if VarEntry <> nil then
    begin
      Dec(VarEntry.FRefCount);
      if VarEntry.FRefCount = 0 then VarEntry.Free;
    end;
  end;
end;

{ Supporting procedures }

procedure RemoveVariantFromCache(var V: Variant);
begin
  VariantCache.Remove(V);
end;

procedure MyVarClear;
asm
  push eax                      // save registers
  push edx
  mov edx, eax                  // put Variant in edx
  lea eax, VariantCache         // put VariantCache object self in eax
  call TVariantCache.Remove     // call Remove
  mov eax, edx                  // put Variant back in eax
  pop edx
  call System.@VarClear         // do normal variant clearing logic
  pop eax
end;

procedure RemapVarClrProc;
var
  JmpInst: array[1..MemSize] of Byte;
  OldProtect: DWORD;
  NewPtr: PByte;
begin
  NewVarClear := @MyVarClear;          // NewFoo holds addr of MyVarClear
  NewPtr := @NewVarClear;              // NewPtr holds addr of NewVarClear
  // set up array containing opcodes for jump...
  JmpInst[1] := $FF;                        // jmp
  JmpInst[2] := $25;                        // dword ptr
  Move(NewPtr, JmpInst[3], SizeOf(NewPtr)); // [NewFoo]
  // Put address of _VarClr into OldVarClear
  asm
    push eax
    mov eax, offset System.@VarClr
    mov OldVarClear, eax
    pop eax
  end;
  // enable read/write/execute permission on _VarClr code
  Win32Check(VirtualProtect(OldVarClear, MemSize, PAGE_EXECUTE_READWRITE,
    @OldProtect));
  // Read old VarClr code
  Move(OldVarClear^, VarClearCode, MemSize);
  // Patch VarClr with new jmp code
  Move(JmpInst, OldVarClear^, MemSize);
end;

// GetIDsOfNames wrapper taken from ComObj.pas
procedure GetIDsOfNames(const Dispatch: IDispatch; Names: PChar;
  NameCount: Integer; DispIDs: PDispIDList);

  procedure RaiseNameException;
  begin
    raise EOleError.CreateFmt('Method ''%s'' not supported by automation object',
      [Names]);
  end;

type
  PNamesArray = ^TNamesArray;
  TNamesArray = array[0..0] of PWideChar;
var
  N, SrcLen, DestLen: Integer;
  Src: PChar;
  Dest: PWideChar;
  NameRefs: PNamesArray;
  StackTop: Pointer;
  Temp: Integer;
begin
  Src := Names;
  N := 0;
  asm
    MOV  StackTop, ESP
    MOV  EAX, NameCount
    INC  EAX
    SHL  EAX, 2  // sizeof pointer = 4
    SUB  ESP, EAX
    LEA  EAX, NameRefs
    MOV  [EAX], ESP
  end;
  repeat
    SrcLen := StrLen(Src);
    DestLen := MultiByteToWideChar(0, 0, Src, SrcLen, nil, 0) + 1;
    asm
      MOV  EAX, DestLen
      ADD  EAX, EAX
      ADD  EAX, 3      // round up to 4 byte boundary
      AND  EAX, not 3
      SUB  ESP, EAX
      LEA  EAX, Dest
      MOV  [EAX], ESP
    end;
    if N = 0 then NameRefs[0] := Dest else NameRefs[NameCount - N] := Dest;
    MultiByteToWideChar(0, 0, Src, SrcLen, Dest, DestLen);
    Dest[DestLen-1] := #0;
    Inc(Src, SrcLen+1);
    Inc(N);
  until N = NameCount;
  Temp := Dispatch.GetIDsOfNames(GUID_NULL, NameRefs, NameCount,
    GetThreadLocale, DispIDs);
  if Temp = Integer(DISP_E_UNKNOWNNAME) then RaiseNameException else OleCheck(Temp);
  asm
    MOV  ESP, StackTop
  end;
end;

procedure CachingVarDispInvoke(Result: PVariant; const Instance: Variant;
  CallDesc: PCallDesc; Params: Pointer); cdecl;

  procedure RaiseException;
  begin
    raise EOleError.Create('Variant does not reference an automation object');
  end;

var
  Dispatch: Pointer;
  DispIDs: array[0..63] of Integer;
  VarEntry: TVariantEntry;
  Names: PChar;
  Count: Integer;
begin
  if TVarData(Instance).VType = varDispatch then
    Dispatch := TVarData(Instance).VDispatch
  else if TVarData(Instance).VType = (varDispatch or varByRef) then
    Dispatch := Pointer(TVarData(Instance).VPointer^)
  else RaiseException;
  Names := @CallDesc^.ArgTypes[CallDesc^.ArgCount];
  Count := CallDesc^.NamedArgCount + 1;
  VarEntry := VariantCache.Find(Instance);
  if (VarEntry = nil) or
    (not VarEntry.GetIdsOfNames(Names, @DispIDs)) then
  begin
    GetIDsOfNames(IDispatch(Dispatch), Names, Count, @DispIDs);
    VariantCache.Add(Instance, Names, @DispIDs, Count);
  end;
  if Result <> nil then VarClear(Result^);
  DispatchInvoke(IDispatch(Dispatch), CallDesc, @DispIDs, @Params, Result);
end;

initialization
  VariantCache := TVariantCache.Create;
  RemapVarClrProc;
  VarDispProc := @CachingVarDispInvoke;
finalization
  VariantCache.Free;
end.